(defpackage :dgraph
  (:use :cl)
  (:export :gen-id
           :convert
           :attributes))

(in-package :dgraph)

(defun id (id)
  (parse-integer (subseq (string id) 1)))

(defun gen-id (node)
  (etypecase node
    (d:input-argument
     (if (char= (char (u:string2 (d:id node)) 0) #\I)
         (d:id node)
         (intern (format nil "I~a" (d:id node)))))
    (d:argument
     (if (char= (char (u:string2 (d:id node)) 0) #\T)
         (d:id node)
         (intern (format nil "T~a" (d:id node)))))
    (d:multi-argument-box
     (if (char= (char (u:string2 (d:id node)) 0) #\B)
         (d:id node)
         (intern (format nil "B~a" (d:id node)))))))

(defun convert (tree)
  (let (boxes tiles arrows)
    (d:funcall-on-tree (lambda (node)
                         (etypecase node
                           (d:invisible-argument)
                           (d:argument
                            (unless (find (d:quantity node) '(+ - / *))
                              (dolist (b (tree:children node))
                                (push (list :a (gen-id b) (gen-id node))
                                      arrows))
                              (push (list* (gen-id node)
                                           (when (d:quantity node)
                                             (list (d:quantity node))))
                                    tiles)))
                           (d:invisible-box)
                           (d:multi-argument-box
                            (push (list* (gen-id node)
                                         (mapcar (lambda (c)
                                                   (if (find (d:quantity c) '(+ - / *))
                                                       (d:quantity c)
                                                       (gen-id c)))
                                                 (tree:children node)))
                                  boxes))))
                       tree)
    (append tiles boxes arrows)))

(defun attributes (tree)
  (let (colors arrows selections highlights)
    (d:funcall-on-tree (lambda (node)
                         (when (and (typep node 'd:argument)
                                    (not (or (find (d:quantity node) '(+ - * /))
                                             (sdl:color= (d:background node) (gwee:gray 240))
                                             (sdl:color= (d:background node) (gwee:color 173 216 230)))))
                           (push (list :c (gen-id node)
                                       (sdl:r (d:background node))
                                       (sdl:g (d:background node))
                                       (sdl:b (d:background node)))
                                 colors))
                         (when (d:selected node)
                           (push (list :s (gen-id node))
                                 selections))
                         (when (d:arrow node)
                           (push (list* :p (gen-id node)
                                        (when (typep (d:arrow node) 'sdl:color)
                                          (list (sdl:r (d:arrow node))
                                                (sdl:g (d:arrow node))
                                                (sdl:b (d:arrow node)))))
                                 arrows))
                         (when (and (typep node 'd:argument)
                                    (not (find (d:quantity node) '(+ - * /)))
                                    (d:highlighted node))
                           (push (list :h (gen-id node))
                                 highlights)))
                       tree)
    (append colors arrows selections highlights)))

(defun convert2 (tree &optional optimize-args)
  (let (boxes tiles)
    (d:funcall-on-tree (lambda (node)
                         (etypecase node
                           (d:invisible-argument)
                           (d:argument
                            (let (props)
                              (when (d:highlighted node) (setf (getf props :highlighted) t))
                              (when (and (not (sdl:color= (d:background node) (gwee:gray 240)))
                                         (not (sdl:color= (d:background node) (gwee:color 173 216 230))))
                                (setf (getf props :background) (list (sdl:r (d:background node))
                                                                     (sdl:g (d:background node))
                                                                     (sdl:b (d:background node)))))
                              (unless (find (d:quantity node) '(+ - / *))
                                (when (d:selected node) (setf (getf props :selected) t))
                                (when (typep node 'd:input-argument)
                                  (setf (getf props :answer) (if (slot-boundp node 'd:answer)
                                                                 (d:answer node)
                                                                 nil))
                                  (when (eq (d:input-location node) :above)
                                    (setf (getf props :input-location) :above))))
                              (push (append (list (gen-id node) (d:quantity node))
                                            (mapcar 'gen-id (tree:children node))
                                            props)
                                    tiles)))
                           (d:invisible-box)
                           (d:multi-argument-box
                            (let (props)
                              (when (d:selected node) (setf (getf props :selected) t))
                              (when (d:highlighted node) (setf (getf props :highlighted) t))
                              (push (append (list (gen-id node))
                                            (mapcar (lambda (c)
                                                      (if (and optimize-args
                                                               (or (find (d:quantity c) '(+ - / *))
                                                                   (and (numberp (d:quantity c))
                                                                        (null (tree:children c)))))
                                                          (d:quantity c)
                                                          (gen-id c)))
                                                    (tree:children node))
                                            props)
                                    boxes)))))
                       tree)
    (append tiles boxes)))
